'2-d array class based on 1-d array - more flexible than VB's 2-d
'V2
'after a suggestion from La Volpe I've generalised this class
'to work with any type of variable
'array is stored in a variant and values are passed as variant
'the earlier version could perhaps be used as a template for
'other specific length variables like bytes or integers
'V3 this one - probably final version
'- defined user type for storing an array with bounds
'Public type can't be put in a class module unfortunately
' and is in the form
'Private Type TwoDArrayType
'tarray As Variant
'tRLBound As Long
'tRUBound As Long
'tCLBound As Long
'tCUBound As Long
'tHASARRAY As Boolean
'tVARTYPE As Integer
'End Type
'- the array can be redim preserved by changing lower as well as
'upper bounds
'- array type can be changed subject to conversion possibilities
'eg long to integer (provided all longs are in integer range) etc
'it'll throw up errors if you choose badly
'Kenneth Buckmaster
Dim arr As Variant, rows As Long, cols As Long, UBarray As Long
Dim RLBound As Long, RUBound As Long, CLBound As Long, CUBound As Long
'for sort
Dim arrstart As Long, colw As Long, sortvertical As Boolean, sortAscending As Boolean
Dim vartypeset As Boolean
Private Sub Class_Initialize()
UBarray = -1
End Sub
Function FetchArray(Optional RLBoundI As Long, Optional CLBoundI As Long, Optional RUBoundI As Long, Optional CUBoundI As Long, Optional Arrvartype As Integer) As Variant
If IsMissing(RLBoundI) = False Then 'need all or none
RLBoundI = RLBound
RUBoundI = RUBound
CLBoundI = CLBound
CUBoundI = CUBound
Arrvartype = VarType(arr(0))
End If
FetchArray = arr
End Function
Sub SetArray(ByVal RLBoundI As Long, ByVal CLBoundI As Long, ByVal RUBoundI As Long, ByVal CUBoundI As Long, newarray As Variant)
vartypeset = True
RLBound = RLBoundI
RUBound = RUBoundI
CLBound = CLBoundI
CUBound = CUBoundI
rows = RUBound - RLBound + 1
cols = CUBound - CLBound + 1
arr = newarray
UBarray = UBound(arr)
End Sub
Sub setvartype(var)
Dim tmp, i As Long
If UBarray <> -1 Then
tmp = arr
End If
Select Case var 'select case required for all vartypes you will use
Case vbInteger
Dim ii() As Integer
arr = ii
Case vbLong
Dim ll() As Long
arr = ll
Case vbString
Dim ss() As String
arr = ss
Case vbDate
Dim dd() As Date
arr = dd
End Select
'changes type of array coercion between array types must be possible
'and everything in range
'no error handling for this so be careful
If UBarray <> -1 Then
ReDim arr(UBarray)
For i = 0 To UBarray
arr(i) = tmp(i)
Next
End If
vartypeset = True
End Sub
Sub ZeroBaseDimension(ByVal newrows As Long, ByVal newcols As Long)
If newrows <= 0 Or newcols <= 0 Then Exit Sub
rows = newrows
cols = newcols
UBarray = ((rows) * (cols)) - 1
ReDim arr(UBarray)
RLBound = 0
CLBound = 0
RUBound = rows - 1
CUBound = cols - 1
End Sub
Sub dimension(ByVal LBRows As Long, ByVal UBRows As Long, ByVal LBcols As Long, ByVal UBCols As Long)
If UBRows < LBRows Or UBCols < LBcols Then Exit Sub
rows = UBRows - LBRows + 1
cols = UBCols - LBcols + 1
UBarray = ((rows) * (cols)) - 1
ReDim arr(UBarray)
RLBound = LBRows
CLBound = LBcols
RUBound = UBRows
CUBound = UBCols
End Sub
Sub resetRowBounds(ByVal RowLbound As Long)
RUBound = RowLbound + rows - 1
RLBound = RowLbound
End Sub
Sub resetColBounds(ByVal ColLbound As Long)
CUBound = ColLbound + cols - 1
CLBound = ColLbound
End Sub
Sub redimPreserveCols(ByVal newcols As Long)
Dim tmpclbound As Long, tmprlbound As Long, oldcols As Long, rowvals As Long, i As Long, postarget As Long, possource As Long
Dim tmp As Variant
If newcols <= 0 Then Exit Sub
tmpclbound = CLBound
tmprlbound = RLBound
tmp = arr
Dim j As Long
oldcols = cols
If newcols < oldcols Then rowvals = newcols Else rowvals = oldcols
ZeroBaseDimension rows, newcols
For i = 0 To rows - 1
For j = 0 To rowvals - 1
arr(postarget + j) = tmp(possource + j)
Next
postarget = postarget + newcols
possource = possource + oldcols
Next
cols = newcols
CLBound = tmpclbound
CUBound = CLBound + cols - 1
RLBound = tmprlbound
RUBound = RLBound + rows - 1
End Sub
Sub redimPreserveROWS(ByVal newrows As Long)
If newrows <= 0 Then Exit Sub
UBarray = ((newrows) * (cols)) - 1
ReDim Preserve arr(UBarray)
rows = newrows
RUBound = RLBound + rows - 1
End Sub
Sub redimPreserve(ByVal newrows As Long, ByVal newcols As Long)
If newrows <= 0 Or newcols <= 0 Then Exit Sub
redimPreserveCols newcols
redimPreserveROWS newrows
End Sub
'*** redim by bounds
Sub redimPreserveByBounds(ByVal NewRUBound As Long, ByVal NewCUBound As Long)
newcols = NewRUBound - RLBound + 1
newrows = NewCUBound - CLBound + 1
redimPreserveCols newcols
redimPreserveROWS newrows
End Sub
Sub redimPreserveByLowerRowBound(ByVal NewRLBound As Long)
Dim ymove As Long, i As Long, j As Long, tmp, end1 As Long, end2 As Long
If NewRLBound > RUBound Then Exit Sub
ymove = NewRLBound - RLBound
If ymove = 0 Then Exit Sub
If ymove > 0 Then
end1 = RLBound + ymove
end2 = RUBound + ymove
For j = RLBound To RUBound Step 1
For i = CLBound To CUBound
tmp = getValue(j, i)
setValue j - ymove, i, tmp
If j < end1 Or j > end2 Then setValue j, i, vbEmpty
Next
Next
End If
redimPreserveROWS RUBound - NewRLBound + 1
If ymove < 0 Then
end1 = RLBound - ymove
end2 = RUBound - ymove
For j = RUBound To RLBound Step -1
For i = CLBound To CUBound
tmp = getValue(j, i)
setValue j - ymove, i, tmp
If j < end1 Or j > end2 Then setValue j, i, vbEmpty
Next
Next
End If
resetRowBounds NewRLBound
End Sub
Sub redimPreserveByLowerColBound(ByVal NewcLBound As Long)
Dim Xmove As Long, i As Long, j As Long, tmp, end1 As Long, end2 As Long
If NewcLBound > CUBound Then Exit Sub
Xmove = NewcLBound - CLBound
If Xmove = 0 Then Exit Sub
If Xmove > 0 Then
end1 = CLBound + Xmove
end2 = CUBound + Xmove
For j = CLBound To CUBound Step 1
For i = RLBound To RUBound
tmp = getValue(i, j)
setValue i, j - Xmove, tmp
If j < end1 Or j > end2 Then setValue i, j, vbEmpty
Next
Next
End If
redimPreserveCols CUBound - NewcLBound + 1
If Xmove < 0 Then
end1 = CLBound - Xmove
end2 = CUBound - Xmove
For j = CUBound To CLBound Step -1
For i = RLBound To RUBound
tmp = getValue(i, j)
setValue i, j - Xmove, tmp
If j < end1 Or j > end2 Then setValue i, j, vbEmpty
Next
Next
End If
resetColBounds NewcLBound
End Sub
Sub redimPreserveByUpperRowBound(ByVal NewRUBound As Long)
redimPreserveROWS NewRUBound - RLBound + 1
End Sub
Sub redimPreserveByUpperColBound(ByVal NewCUBound As Long)
redimPreserveCols NewCUBound - CLBound + 1
End Sub
'*** end redim by bounds
Sub setValue(ByVal row As Long, ByVal col As Long, VALUE As Variant)
If checkBounds(row, col) = False Then Exit Sub
arr(((row - RLBound) * cols) + col - CLBound) = VALUE
End Sub
Function getValue(ByVal row As Long, ByVal col As Long) As Variant
If checkBounds(row, col) = False Then Exit Function
